home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / ratio.t < prev    next >
Text File  |  1988-05-02  |  3KB  |  95 lines
  1. (herald ratio (env tsys))
  2.  
  3. ;;; copyright (c) 1983, 1984 yale university
  4.  
  5. (define (ratio p q)
  6.   (let ((p (enforce integer? p))
  7.         (q (enforce integer? q))
  8.         (normal (lambda (p q)
  9.                   (let ((g (gcd p q)))
  10.                     (let ((p (quotient p g))
  11.                           (q (quotient q g)))
  12.                       (cond ((= q 1) p)
  13.                             (else (object nil
  14.                                        ((extended-number-type self)
  15.                                         %%ratio-number-type)
  16.                                        ((ratio? self) t)
  17.                                        ((numerator self) p)
  18.                                        ((denominator self) q)
  19.                                        ((print self port)
  20.                                         (format port "~s~c~s"
  21.                                                 p ratio-char q))))))))))
  22.     ;; ... put p & q in lowest terms ...
  23.     (cond ((= q 0) (error "attempt to divide by zero~%  (/ ~s ~s)" p q))
  24.           ((< q 0) (normal (- 0 p) (- 0 q)))
  25.           (else (normal p q)))))
  26.  
  27. (define-predicate ratio?)
  28.  
  29. (define (rational? x)
  30.   (or (integer? x) (ratio? x)))
  31.  
  32. (define-operation (numerator x)
  33.   (cond ((integer? x) x)
  34.         (else (error "cannot take numerator of non-integer ~s" x))))
  35.  
  36. (define-operation (denominator x)
  37.   (cond ((integer? x) 1)
  38.         (else (error "cannot take denominator of non-integer ~s" x))))
  39.  
  40. (define (rational-parts-add n1 d1 n2 d2)
  41.   (ratio (+ (* n1 d2) (* n2 d1))
  42.          (* d1 d2)))
  43.  
  44. (define (rational-parts-subtract n1 d1 n2 d2)
  45.   (ratio (- (* n1 d2) (* n2 d1))
  46.          (* d1 d2)))
  47.  
  48. (define (rational-parts-multiply n1 d1 n2 d2)
  49.   (ratio (* n1 n2) 
  50.          (* d1 d2)))
  51.  
  52. (define-integrable (rational-parts-divide n1 d1 n2 d2)
  53.   (rational-parts-multiply n1 d1 d2 n2))
  54.  
  55. (define (rational-parts-quotient n1 d1 n2 d2)
  56.   (quotient (* n1 d2)
  57.             (* n2 d1)))
  58.  
  59. ;;; hacked for consistency
  60.  
  61. (define (rational-add r1 r2) 
  62.   (rational-op rational-parts-add r1 r2))
  63.  
  64. (define (rational-subtract r1 r2) 
  65.   (rational-op rational-parts-subtract r1 r2))
  66.  
  67. (define (rational-multiply r1 r2) 
  68.   (rational-op rational-parts-multiply r1 r2))
  69.  
  70. (define (rational-divide r1 r2) 
  71.   (rational-op rational-parts-divide r1 r2))
  72.  
  73. (define (rational-quotient r1 r2)
  74.   (rational-op rational-parts-quotient r1 r2))
  75.  
  76. (define (rational-less? r1 r2)
  77.   (< (* (numerator r1) (denominator r2)) (* (numerator r2) (denominator r1))))
  78.  
  79. (define (rational-equal? r1 r2)
  80.   ;; assume normalization.
  81.   (and (= (numerator r1)   (numerator r2))
  82.        (= (denominator r2) (denominator r1))))
  83.  
  84. (define (rational-op proc r1 r2)
  85.   (proc (numerator r1)
  86.         (denominator r1)
  87.         (numerator r2)
  88.         (denominator r2)))
  89.  
  90. ;;; coercers
  91.  
  92. (define (ratio->flonum r)
  93.   (flonum-divide (integer->flonum (numerator r))
  94.                  (integer->flonum (denominator r))))
  95.